home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / music / 309 / gfa / gfacust.gfa (.txt) < prev    next >
GFA-BASIC Atari  |  1988-09-19  |  27KB  |  970 lines
  1. ' GFACUST.GFA
  2. '
  3. ' Customizing program for GFA BASIC 3.0
  4. ' Version 1.0 (09/88)
  5. ' By Don Bush
  6. ' GEnie: D.BUSH
  7. '
  8. ' This program may be redistributed freely for non-profit purposes only.
  9. '
  10. '
  11. ' First we force GEM to redraw it's desktop
  12. ~WIND_GET(0,4,dx%,dy%,dw%,dh%)
  13. ~FORM_DIAL(3,dx%,dy%,dw%,dh%,dx%,dy%,dw%,dh%)
  14. '
  15. ' Make sure we are in the proper resolution
  16. IF (XBIOS(4)=0)
  17.   ~FORM_ALERT(1,"[1][This program only runs|in medium or high|resolution][OK]")
  18.   END
  19. ENDIF
  20. '
  21. ' Load the resource file
  22. IF (RSRC_LOAD("GFACUST.RSC")=0)
  23.   ~FORM_ALERT(1,"[1][Could not find|GFACUST.RSC][OK]")
  24.   END
  25. ENDIF
  26. '
  27. ' Initialize global variables which will hold our customization info
  28. @init_globals
  29. '
  30. ' Initialize the resource file index variables and the pointers to
  31. ' the resource trees.
  32. @init_index_vars
  33. @init_tree_pointers
  34. '
  35. ' Display the menu bar
  36. ~MENU_BAR(menu_tree%,1)
  37. '
  38. ' Install our error trapping procedure
  39. ON ERROR GOSUB error_exit
  40. '
  41. ' Go do our main program loop
  42. @process_events
  43. '
  44. ' Remove the menu bar, free the resource, and end the program
  45. ~MENU_BAR(menu_tree%,0)
  46. ~RSRC_FREE()
  47. CLS
  48. END
  49. '
  50. '
  51. > PROCEDURE init_globals
  52.   basic_file$="GFABASIC.PRG"
  53.   basro_file$="GFABASRO.PRG"
  54.   '
  55.   clear_screen_ba!=TRUE
  56.   clear_screen_ro!=TRUE
  57.   '
  58.   auto_program$=CHR$(0)
  59.   '
  60.   DIM var_type%(26)
  61.   ARRAYFILL var_type%(),0
  62.   DIM var_type_idx%(6)
  63.   var_type_idx%(0)=0
  64.   var_type_idx%(1)=1
  65.   var_type_idx%(2)=3
  66.   var_type_idx%(3)=2
  67.   var_type_idx%(4)=8
  68.   var_type_idx%(5)=9
  69.   vt_char$="#$!%&|"
  70.   '
  71.   DIM editor_colors%(4)
  72.   editor_colors%(0)=&H777
  73.   editor_colors%(1)=&H700
  74.   editor_colors%(2)=&H70
  75.   editor_colors%(3)=&H0
  76.   '
  77.   default_deflist%=0
  78.   '
  79.   default_pl%=60
  80.   default_ll%=80
  81.   default_he$=CHR$(0)
  82.   default_fo$=CHR$(0)
  83.   default_in$=CHR$(0)
  84.   default_ff$=CHR$(0)
  85. RETURN
  86. > PROCEDURE init_index_vars
  87.   menu%=0! menu tree
  88.   tdesk%=3! TITLE in tree MENU
  89.   tfile%=4! TITLE in tree MENU
  90.   tbasic%=5! TITLE in tree MENU
  91.   tbasro%=6! TITLE in tree MENU
  92.   iabout%=9! STRING in tree MENU
  93.   irdbasic%=18! STRING in tree MENU
  94.   iupbasic%=19! STRING in tree MENU
  95.   irdbasro%=21! STRING in tree MENU
  96.   iupbasro%=22! STRING in tree MENU
  97.   iquit%=24! STRING in tree MENU
  98.   ibaerase%=26! STRING in tree MENU
  99.   ibatypes%=27! STRING in tree MENU
  100.   ibacolor%=28! STRING in tree MENU
  101.   ibadlist%=29! STRING in tree MENU
  102.   iballist%=30! STRING in tree MENU
  103.   iroerase%=32! STRING in tree MENU
  104.   irodeflt%=33! STRING in tree MENU
  105.   dabout%=1! form/dialog
  106.   derase%=2! form/dialog
  107.   dererase%=5! BOXTEXT in tree DERASE
  108.   dernoera%=6! BOXTEXT in tree DERASE
  109.   derok%=7! BUTTON in tree DERASE
  110.   dercancl%=8! BUTTON in tree DERASE
  111.   dvartype%=3! form/dialog
  112.   dvatypea%=5! BUTTON in tree DVARTYPE
  113.   dvaok%=31! BUTTON in tree DVARTYPE
  114.   dvacancl%=32! BUTTON in tree DVARTYPE
  115.   ddeflist%=4! form/dialog
  116.   dde0%=11! BUTTON in tree DDEFLIST
  117.   ddeok%=15! BUTTON in tree DDEFLIST
  118.   ddecancl%=16! BUTTON in tree DDEFLIST
  119.   dllist%=5! form/dialog
  120.   dllok%=2! BUTTON in tree DLLIST
  121.   dllcancl%=3! BUTTON in tree DLLIST
  122.   dllpl%=4! FTEXT in tree DLLIST
  123.   dllll%=5! FTEXT in tree DLLIST
  124.   dllhe%=6! FTEXT in tree DLLIST
  125.   dllfo%=7! FTEXT in tree DLLIST
  126.   dllin%=8! FTEXT in tree DLLIST
  127.   dllff%=9! FTEXT in tree DLLIST
  128.   dcolors%=6! form/dialog
  129.   dcobkup1%=5! BOXCHAR in tree DCOLORS
  130.   dcobkup3%=7! BOXCHAR in tree DCOLORS
  131.   dcobknum%=8! BUTTON in tree DCOLORS
  132.   dcobkdn1%=11! BOXCHAR in tree DCOLORS
  133.   dcobkdn3%=13! BOXCHAR in tree DCOLORS
  134.   dcotxup1%=17! BOXCHAR in tree DCOLORS
  135.   dcotxup3%=19! BOXCHAR in tree DCOLORS
  136.   dcotxnum%=20! BUTTON in tree DCOLORS
  137.   dcotxdn1%=23! BOXCHAR in tree DCOLORS
  138.   dcotxdn3%=25! BOXCHAR in tree DCOLORS
  139.   dcocrup1%=29! BOXCHAR in tree DCOLORS
  140.   dcocrup3%=31! BOXCHAR in tree DCOLORS
  141.   dcocrnum%=32! BUTTON in tree DCOLORS
  142.   dcocrdn1%=35! BOXCHAR in tree DCOLORS
  143.   dcocrdn3%=37! BOXCHAR in tree DCOLORS
  144.   dcoblup1%=41! BOXCHAR in tree DCOLORS
  145.   dcoblup3%=43! BOXCHAR in tree DCOLORS
  146.   dcoblnum%=44! BUTTON in tree DCOLORS
  147.   dcobldn1%=47! BOXCHAR in tree DCOLORS
  148.   dcobldn3%=49! BOXCHAR in tree DCOLORS
  149.   dcook%=50! BUTTON in tree DCOLORS
  150.   dcocancl%=51! BUTTON in tree DCOLORS
  151.   dverify%=7! form/dialog
  152.   dvetext%=2! FTEXT in tree DVERIFY
  153.   dveok%=3! BUTTON in tree DVERIFY
  154.   dvecancl%=4! BUTTON in tree DVERIFY
  155.   dprogram%=8! form/dialog
  156.   dprok%=2! BUTTON in tree DPROGRAM
  157.   dprcancl%=3! BUTTON in tree DPROGRAM
  158.   dprfsel%=7! BOXTEXT in tree DPROGRAM
  159.   dprtext%=9! FTEXT in tree DPROGRAM
  160.   dcolrmon%=9! form/dialog
  161.   dcmnorm%=2! BOX in tree DCOLRMON
  162.   dcminvrs%=4! BOX in tree DCOLRMON
  163.   dcmok%=7! BUTTON in tree DCOLRMON
  164.   dcmcancl%=8! BUTTON in tree DCOLRMON
  165.   aexistba%=0! Alert string index
  166.   awarnbas%=1! Alert string index
  167.   awarnro%=2! Alert string index
  168.   aexistro%=3! Alert string index
  169. RETURN
  170. > PROCEDURE init_tree_pointers
  171.   ' Find the addresses of the menu and dialog trees
  172.   ~RSRC_GADDR(0,menu%,menu_tree%)
  173.   ~RSRC_GADDR(0,dabout%,dabout_tree%)
  174.   ~RSRC_GADDR(0,derase%,derase_tree%)
  175.   ~RSRC_GADDR(0,dvartype%,dvartype_tree%)
  176.   ~RSRC_GADDR(0,ddeflist%,ddeflist_tree%)
  177.   ~RSRC_GADDR(0,dllist%,dllist_tree%)
  178.   ~RSRC_GADDR(0,dprogram%,dprogram_tree%)
  179.   ~RSRC_GADDR(0,dcolors%,dcolors_tree%)
  180.   ~RSRC_GADDR(0,dverify%,dverify_tree%)
  181.   ~RSRC_GADDR(0,dcolrmon%,dcolrmon_tree%)
  182.   '
  183.   ' Find the addresses of the alert strings
  184.   ~RSRC_GADDR(5,aexistba%,aexistba_alert%)
  185.   ~RSRC_GADDR(5,aexistro%,aexistro_alert%)
  186.   ~RSRC_GADDR(5,awarnbas%,awarnbas_alert%)
  187.   ~RSRC_GADDR(5,awarnro%,awarnro_alert%)
  188. RETURN
  189. > PROCEDURE process_events
  190.   LOCAL msg$,message_id&,menu_title&,menu_item&
  191.   '
  192.   ' Initialize our message buffer and some variables to make it convenient
  193.   msg$=SPACE$(16)
  194.   ABSOLUTE message_id&,V:msg$
  195.   ABSOLUTE menu_title&,V:msg$+6
  196.   ABSOLUTE menu_item&,V:msg$+8
  197.   '
  198.   ' This loop will be executed until the user selects the 'Quit' menu item
  199.   DO
  200.     ' Wait for the user to select a menu item
  201.     ~EVNT_MESAG(V:msg$)
  202.     IF message_id&=10      ! 10 = a menu message
  203.       EXIT IF menu_item&=iquit%
  204.       @process_menu_selection(menu_title&,menu_item&)
  205.       ' Reset the menu title to display normally
  206.       ~MENU_TNORMAL(menu_tree%,menu_title&,1)
  207.     ENDIF
  208.   LOOP
  209. RETURN
  210. > PROCEDURE process_menu_selection(title%,item%)
  211.   ' This procedure simply calls various procedures based upon the users menu
  212.   ' selectons.
  213.   LOCAL button%
  214.   SELECT item%
  215.   CASE iabout%
  216.     @do_dialog(dabout_tree%,0,button%)
  217.   CASE irdbasic%
  218.     @read_gfabasic
  219.   CASE iupbasic%
  220.     @update_gfabasic
  221.   CASE irdbasro%
  222.     @read_gfabasro
  223.   CASE iupbasro%
  224.     @update_gfabasro
  225.   CASE ibaerase%
  226.     @do_erase_dialog(1)
  227.   CASE iroerase%
  228.     @do_erase_dialog(0)
  229.   CASE ibatypes%
  230.     @do_vartype_dialog
  231.   CASE ibacolor%
  232.     IF XBIOS(4)=2
  233.       @do_mono_color_dialog
  234.     ELSE
  235.       @do_colors_dialog
  236.     ENDIF
  237.   CASE ibadlist%
  238.     @do_deflist_dialog
  239.   CASE iballist%
  240.     @do_llist_dialog
  241.   CASE irodeflt%
  242.     @do_program_dialog
  243.   ENDSELECT
  244. RETURN
  245. > PROCEDURE read_gfabasic
  246.   ' This procedure reads the customization information from a GFABASIC.PRG file
  247.   LOCAL i%,j%,k%,button%
  248.   DO
  249.     @select_file("PRG","Select GFABASIC.PRG to read...",basic_file$,button%)
  250.     EXIT IF button%=0 OR EXIST(basic_file$)
  251.     ~FORM_ALERT(1,CHAR{aexistba_alert%})
  252.   LOOP
  253.   IF button%   !if user pressed ok
  254.     OPEN "I",#1,basic_file$
  255.     '
  256.     ' Read the screen erase value
  257.     SEEK #1,31
  258.     IF INP(#1)=ASC("E")
  259.       clear_screen_ba!=TRUE
  260.     ELSE
  261.       clear_screen_ba!=FALSE
  262.     ENDIF
  263.     '
  264.     ' Read the variable types
  265.     SEEK #1,32
  266.     FOR i%=0 TO 25
  267.       j%=INP(#1)
  268.       FOR k%=0 TO 5
  269.         EXIT IF var_type_idx%(k%)=j%
  270.       NEXT k%
  271.       var_type%(i%)=k%
  272.     NEXT i%
  273.     '
  274.     ' Read the editor colors
  275.     SEEK #1,58
  276.     FOR i%=0 TO 3
  277.       editor_colors%(i%)=INP(#1)*256+INP(#1)
  278.     NEXT i%
  279.     '
  280.     ' Read the DEFLIST value
  281.     SEEK #1,80
  282.     default_deflist%=INP(#1)*256+INP(#1)
  283.     '
  284.     ' Read the LLIST line length and page length values
  285.     SEEK #1,82
  286.     default_pl%=INP(#1)*256+INP(#1)
  287.     SEEK #1,86
  288.     default_ll%=INP(#1)*256+INP(#1)
  289.     '
  290.     ' Read the LLIST header string
  291.     SEEK #1,88
  292.     default_he$=""
  293.     FOR i%=1 TO 32
  294.       j%=INP(#1)
  295.       EXIT IF j%=13 OR j%=0
  296.       default_he$=default_he$+CHR$(j%)
  297.     NEXT i%
  298.     default_he$=default_he$+CHR$(0)
  299.     '
  300.     ' Read the LLIST footer string
  301.     SEEK #1,120
  302.     default_fo$=""
  303.     FOR i%=1 TO 32
  304.       j%=INP(#1)
  305.       EXIT IF j%=13 OR j%=0
  306.       default_fo$=default_fo$+CHR$(j%)
  307.     NEXT i%
  308.     default_fo$=default_fo$+CHR$(0)
  309.     '
  310.     ' Read the LLIST initialization string
  311.     SEEK #1,152
  312.     default_in$=""
  313.     FOR i%=1 TO 32
  314.       j%=INP(#1)
  315.       EXIT IF j%=13 OR j%=0
  316.       default_in$=default_in$+CHR$(j%)
  317.     NEXT i%
  318.     default_in$=default_in$+CHR$(0)
  319.     '
  320.     ' Read the LLIST formfeed string
  321.     SEEK #1,184
  322.     default_ff$=""
  323.     FOR i%=1 TO 32
  324.       j%=INP(#1)
  325.       EXIT IF j%=13 OR j%=0
  326.       default_ff$=default_ff$+CHR$(j%)
  327.     NEXT i%
  328.     default_ff$=default_ff$+CHR$(0)
  329.     '
  330.     CLOSE #1
  331.   ENDIF
  332. RETURN
  333. > PROCEDURE update_gfabasic
  334.   ' This procedure writes the customization info to a GFABASIC.PRG file
  335.   LOCAL i%,button%
  336.   ~FORM_ALERT(1,CHAR{awarnbas_alert%})
  337.   DO
  338.     @select_file("PRG","Select GFABASIC.PRG to customize...",basic_file$,button%)
  339.     EXIT IF button%=0 OR EXIST(basic_file$)
  340.     ~FORM_ALERT(1,CHAR{aexistba_alert%})
  341.   LOOP
  342.   IF button%    ! if user pressed the OK button
  343.     ' Warn the user
  344.     CHAR{{OB_SPEC(dverify_tree%,dvetext%)}}=basic_file$
  345.     @do_dialog(dverify_tree%,0,button%)
  346.     IF button%=dveok%
  347.       OPEN "U",#1,basic_file$
  348.       '
  349.       ' Write the clear screen flag
  350.       SEEK #1,31
  351.       IF clear_screen_ba!
  352.         OUT #1,ASC("E")
  353.       ELSE
  354.         OUT #1,ASC("H")
  355.       ENDIF
  356.       '
  357.       ' Write the variable types
  358.       SEEK #1,32
  359.       FOR i%=0 TO 25
  360.         OUT #1,var_type_idx%(var_type%(i%))
  361.       NEXT i%
  362.       '
  363.       ' Write the editor colors
  364.       SEEK #1,58
  365.       FOR i%=0 TO 3
  366.         PRINT #1,MKI$(editor_colors%(i%));
  367.       NEXT i%
  368.       '
  369.       ' Write the DEFLIST value
  370.       SEEK #1,80
  371.       PRINT #1,MKI$(default_deflist%);
  372.       '
  373.       ' Write the LLIST page length and line length values
  374.       SEEK #1,82
  375.       PRINT #1,MKI$(default_pl%);
  376.       SEEK #1,86
  377.       PRINT #1,MKI$(default_ll%);
  378.       '
  379.       ' Write the LLIST header string
  380.       SEEK #1,88
  381.       IF LEN(default_he$)<1
  382.         OUT #1,0
  383.       ELSE
  384.         PRINT #1;default_he$+CHR$(13);
  385.       ENDIF
  386.       '
  387.       ' Write the LLIST footer string
  388.       SEEK #1,120
  389.       IF LEN(default_fo$)<1
  390.         OUT #1,0
  391.       ELSE
  392.         PRINT #1;default_fo$+CHR$(13);
  393.       ENDIF
  394.       '
  395.       ' Write the LLIST initialization string
  396.       SEEK #1,152
  397.       IF LEN(default_in$)<1
  398.         OUT #1,0
  399.       ELSE
  400.         PRINT #1;default_in$+CHR$(13);
  401.       ENDIF
  402.       '
  403.       ' Write the LLIST formfeed string
  404.       SEEK #1,184
  405.       IF LEN(default_ff$)<1
  406.         OUT #1,0
  407.       ELSE
  408.         PRINT #1;default_ff$+CHR$(13);
  409.       ENDIF
  410.       '
  411.       CLOSE #1
  412.     ENDIF
  413.   ENDIF
  414. RETURN
  415. > PROCEDURE read_gfabasro
  416.   ' This procedure reads the customization info from a GFABASRO.PRG file
  417.   LOCAL i%,j%,k%,button%
  418.   DO
  419.     @select_file("PRG","Select GFABASRO.PRG to read...",basro_file$,button%)
  420.     EXIT IF button%=0 OR EXIST(basro_file$)
  421.     ~FORM_ALERT(1,CHAR{aexistro_alert%})
  422.   LOOP
  423.   IF button%
  424.     OPEN "I",#1,basro_file$
  425.     '
  426.     ' Read the clear-screen flag
  427.     SEEK #1,31
  428.     IF INP(#1)=ASC("E")
  429.       clear_screen_ro!=TRUE
  430.     ELSE
  431.       clear_screen_ro!=FALSE
  432.     ENDIF
  433.     '
  434.     ' Read the name of the auto program
  435.     SEEK #1,32
  436.     auto_program$=""
  437.     FOR i%=1 TO 63
  438.       j%=INP(#1)
  439.       EXIT IF j%=0
  440.       auto_program$=auto_program$+CHR$(j%)
  441.     NEXT i%
  442.     auto_program$=auto_program$+CHR$(0)
  443.     '
  444.     CLOSE #1
  445.   ENDIF
  446. RETURN
  447. > PROCEDURE update_gfabasro
  448.   ' This procedure writes the customization info to a GFABASRO.PRG file
  449.   LOCAL i%,button%
  450.   ~FORM_ALERT(1,CHAR{awarnro_alert%})
  451.   DO
  452.     @select_file("PRG","Select GFABASRO.PRG to customize...",basro_file$,button%)
  453.     EXIT IF button%=0 OR EXIST(basro_file$)
  454.     ~FORM_ALERT(1,CHAR{aexistro_alert%})
  455.   LOOP
  456.   IF button%
  457.     ' Warn the user
  458.     CHAR{{OB_SPEC(dverify_tree%,dvetext%)}}=basro_file$
  459.     @do_dialog(dverify_tree%,0,button%)
  460.     IF button%=dveok%
  461.       OPEN "U",#1,basro_file$
  462.       '
  463.       ' Write the clear-screen flag
  464.       SEEK #1,31
  465.       IF clear_screen_ro!
  466.         OUT #1,ASC("E")
  467.       ELSE
  468.         OUT #1,ASC("H")
  469.       ENDIF
  470.       '
  471.       ' Write the auto-program name
  472.       SEEK #1,32
  473.       PRINT #1;auto_program$;CHR$(0);
  474.       '
  475.       CLOSE #1
  476.     ENDIF
  477.   ENDIF
  478. RETURN
  479. > PROCEDURE do_erase_dialog(flag%)
  480.   LOCAL status!,button%
  481.   ' Flag% is 1 if we are editing the default screen erase for GFABASIC.PRG
  482.   ' it is 0 for GFABASRO.PRG
  483.   IF flag%
  484.     status!=clear_screen_ba!
  485.   ELSE
  486.     status!=clear_screen_ro!
  487.   ENDIF
  488.   ' Initialize the radio buttons
  489.   IF status!
  490.     OB_STATE(derase_tree%,dererase%)=BSET(OB_STATE(derase_tree%,dererase%),0)
  491.     OB_STATE(derase_tree%,dernoera%)=BCLR(OB_STATE(derase_tree%,dernoera%),0)
  492.   ELSE
  493.     OB_STATE(derase_tree%,dererase%)=BCLR(OB_STATE(derase_tree%,dererase%),0)
  494.     OB_STATE(derase_tree%,dernoera%)=BSET(OB_STATE(derase_tree%,dernoera%),0)
  495.   ENDIF
  496.   ' animate the dialog
  497.   do_dialog(derase_tree%,0,button%)
  498.   IF button%=derok%
  499.     ' Save users new screen-erase choice
  500.     status!=BTST(OB_STATE(derase_tree%,dererase%),0)
  501.     IF flag%
  502.       clear_screen_ba!=status!
  503.     ELSE
  504.       clear_screen_ro!=status!
  505.     ENDIF
  506.   ENDIF
  507. RETURN
  508. > PROCEDURE do_vartype_dialog
  509.   LOCAL i%,x%,y%,w%,h%,t$
  510.   '
  511.   ' Make sure button texts reflect current variable types
  512.   FOR i%=0 TO 25
  513.     t$=CHAR{OB_SPEC(dvartype_tree%,dvatypea%+i%)}
  514.     MID$(t$,3,1)=MID$(vt_char$,var_type%(i%)+1,1)
  515.     CHAR{OB_SPEC(dvartype_tree%,dvatypea%+i%)}=t$
  516.   NEXT i%
  517.   '
  518.   ' Center and draw our dialog
  519.   ~FORM_CENTER(dvartype_tree%,x%,y%,w%,h%)
  520.   ~FORM_DIAL(0,0,0,0,0,x%,y%,w%,h%)
  521.   ~OBJC_DRAW(dvartype_tree%,0,10,x%,y%,w%,h%)
  522.   '
  523.   DO
  524.     ' Animate the dialog
  525.     button%=FORM_DO(dvartype_tree%,0)
  526.     ' We mask off high bit of button% which is set by GEM if the button
  527.     ' type was touchexit and the user double-clicked it.
  528.     button%=AND(button%,&H7FFF)
  529.     '
  530.     ' Deselect button
  531.     OB_STATE(dvartype_tree%,button%)=BCLR(OB_STATE(dvartype_tree%,button%),0)
  532.     '
  533.     ' Exit loop if user pressed OK or CANCEL
  534.     EXIT IF button%=dvaok% OR button%=dvacancl%
  535.     '
  536.     ' Get old button text
  537.     t$=CHAR{OB_SPEC(dvartype_tree%,button%)}
  538.     '
  539.     ' Find index of current type character in vt_char$ and add 1
  540.     i%=INSTR(vt_char$,MID$(t$,3,1))+1
  541.     ' Make sure we did not go out of range
  542.     IF i%>LEN(vt_char$)
  543.       i%=1
  544.     ENDIF
  545.     '
  546.     ' Update button text with new type character and redraw the button
  547.     MID$(t$,3,1)=MID$(vt_char$,i%,1)
  548.     CHAR{OB_SPEC(dvartype_tree%,button%)}=t$
  549.     ~OBJC_DRAW(dvartype_tree%,button%,0,x%,y%,w%,h%)
  550.     '
  551.     ' If the user is holding the button down then delay a bit to slow down
  552.     ' the display
  553.     IF MOUSEK
  554.       PAUSE 12
  555.     ENDIF
  556.   LOOP
  557.   '
  558.   IF button%=dvaok%  !if user pressed OK button
  559.     ' update current variable types with values from button texts
  560.     FOR i%=0 TO 25
  561.       t$=MID$(CHAR{OB_SPEC(dvartype_tree%,dvatypea%+i%)},3,1)
  562.       var_type%(i%)=INSTR(vt_char$,t$)-1
  563.     NEXT i%
  564.   ENDIF
  565.   ' Cause GEM to redraw area where our dialog was
  566.   ~FORM_DIAL(3,0,0,0,0,x%,y%,w%,h%)
  567. RETURN
  568. '
  569. > PROCEDURE do_colors_dialog
  570.   LOCAL button%,x%,y%,w%,h%
  571.   LOCAL red%,green%,blue%
  572.   LOCAL i%,temp%
  573.   LOCAL colr$
  574.   '
  575.   ' Save current color register values so we can restore them later
  576.   @save_color_registers(colr$)
  577.   '
  578.   ' Initialize our dialog to show current color info
  579.   @put_colors_into_dialog(dcolors_tree%,dcobknum%,editor_colors%(0))
  580.   @put_colors_into_dialog(dcolors_tree%,dcotxnum%,editor_colors%(3))
  581.   @put_colors_into_dialog(dcolors_tree%,dcocrnum%,editor_colors%(2))
  582.   @put_colors_into_dialog(dcolors_tree%,dcoblnum%,editor_colors%(1))
  583.   '
  584.   ' Center and draw the dialog
  585.   ~FORM_CENTER(dcolors_tree%,x%,y%,w%,h%)
  586.   ~FORM_DIAL(0,0,0,0,0,x%,y%,w%,h%)
  587.   ~OBJC_DRAW(dcolors_tree%,0,10,x%,y%,w%,h%)
  588.   ' Now we set the colors into the color registers
  589.   @draw_rgb_boxes_and_show_color(dcolors_tree%,dcobknum%)
  590.   @draw_rgb_boxes_and_show_color(dcolors_tree%,dcotxnum%)
  591.   @draw_rgb_boxes_and_show_color(dcolors_tree%,dcocrnum%)
  592.   @draw_rgb_boxes_and_show_color(dcolors_tree%,dcoblnum%)
  593.   '
  594.   REPEAT
  595.     ' Animate the dialog
  596.     button%=FORM_DO(dcolors_tree%,start%)
  597.     '
  598.     ' The next line masks off high bit of exit button which is set if button
  599.     ' was 'touchexit' and user double-clicked.
  600.     button%=AND(button%,&H7FFF)
  601.     '
  602.     SELECT button%
  603.     CASE dcobkup1% TO dcobkup3%,dcotxup1% TO dcotxup3%,dcocrup1% TO dcocrup3%,dcoblup1% TO dcoblup3%
  604.       ' User selected an up arrow so we increment the r/g/b value and redraw
  605.       temp%=VAL(CHAR{OB_SPEC(dcolors_tree%,button%+3)})
  606.       IF temp%<7
  607.         ADD temp%,1
  608.         CHAR{OB_SPEC(dcolors_tree%,button%+3)}=STR$(temp%)
  609.         @draw_rgb_boxes_and_show_color(dcolors_tree%,button%+3)
  610.       ENDIF
  611.       PAUSE 12
  612.     CASE dcobkdn1% TO dcobkdn3%,dcotxdn1% TO dcotxdn3%,dcocrdn1% TO dcocrdn3%,dcobldn1% TO dcobldn3%
  613.       ' User selected a down arrow so we decrement the r/g/b value and redraw
  614.       temp%=VAL(CHAR{OB_SPEC(dcolors_tree%,button%-3)})
  615.       IF temp%>0
  616.         SUB temp%,1
  617.         CHAR{OB_SPEC(dcolors_tree%,button%-3)}=STR$(temp%)
  618.         @draw_rgb_boxes_and_show_color(dcolors_tree%,button%-3)
  619.       ENDIF
  620.       PAUSE 12
  621.     ENDSELECT
  622.   UNTIL button%=dcocancl% OR button%=dcook%
  623.   '
  624.   ' Deselect the exit button so it will not be inverse next time it is drawn
  625.   OB_STATE(dcolors_tree%,button%)=BCLR(OB_STATE(dcolors_tree%,button%),0)
  626.   '
  627.   ' Tell GEM to redraw the screen area that was occupied by our dialog
  628.   ~FORM_DIAL(3,0,0,0,0,x%,y%,w%,h%)
  629.   '
  630.   ' Restore color registers
  631.   @restore_color_registers(colr$)
  632.   '
  633.   IF button%=dcook%
  634.     ' User pressed OK so we update our global color info array
  635.     editor_colors%(0)=@get_colors_from_dialog(dcolors_tree%,dcobknum%)
  636.     editor_colors%(3)=@get_colors_from_dialog(dcolors_tree%,dcotxnum%)
  637.     editor_colors%(2)=@get_colors_from_dialog(dcolors_tree%,dcocrnum%)
  638.     editor_colors%(1)=@get_colors_from_dialog(dcolors_tree%,dcoblnum%)
  639.   ENDIF
  640. RETURN
  641. > PROCEDURE put_colors_into_dialog(tree%,index%,colr%)
  642.   LOCAL red%,green%,blue%
  643.   @get_rgb(colr%,red%,green%,blue%)
  644.   CHAR{OB_SPEC(tree%,index%)}=STR$(red%)
  645.   CHAR{OB_SPEC(tree%,index%+1)}=STR$(green%)
  646.   CHAR{OB_SPEC(tree%,index%+2)}=STR$(blue%)
  647. RETURN
  648. FUNCTION get_colors_from_dialog(tree%,index%)
  649.   LOCAL red%,green%,blue%,colr%
  650.   red%=VAL(CHAR{OB_SPEC(tree%,index%)})
  651.   green%=VAL(CHAR{OB_SPEC(tree%,index%+1)})
  652.   blue%=VAL(CHAR{OB_SPEC(tree%,index%+2)})
  653.   @set_rgb(red%,green%,blue%,colr%)
  654.   RETURN colr%
  655. ENDFUNC
  656. > PROCEDURE draw_rgb_boxes_and_show_color(tree%,index%)
  657.   LOCAL reg%,r%,g%,b%
  658.   IF index%>=dcobknum% AND index%<=dcobknum%+2
  659.     index%=dcobknum%
  660.     reg%=0
  661.   ELSE IF index%>=dcotxnum% AND index%<=dcotxnum%+2
  662.     index%=dcotxnum%
  663.     reg%=1
  664.   ELSE IF index%>=dcocrnum% AND index%<=dcocrnum%+2
  665.     index%=dcocrnum%
  666.     reg%=3
  667.   ELSE IF index%>=dcoblnum% AND index%<=dcoblnum%+2
  668.     index%=dcoblnum%
  669.     reg%=2
  670.   ELSE
  671.     GOTO done
  672.   ENDIF
  673.   ~OBJC_DRAW(tree%,index%,10,x%,y%,w%,h%)
  674.   ~OBJC_DRAW(tree%,index%+1,10,x%,y%,w%,h%)
  675.   ~OBJC_DRAW(tree%,index%+2,10,x%,y%,w%,h%)
  676.   r%=VAL(CHAR{OB_SPEC(tree%,index%)})
  677.   g%=VAL(CHAR{OB_SPEC(tree%,index%+1)})
  678.   b%=VAL(CHAR{OB_SPEC(tree%,index%+2)})
  679.   VSETCOLOR reg%,r%,g%,b%
  680. done:
  681. RETURN
  682. > PROCEDURE get_rgb(colr%,VAR r%,g%,b%)
  683.   r%=SHR(colr%,8)
  684.   g%=SHR(AND(colr%,&HF0),4)
  685.   b%=AND(colr%,&HF)
  686. RETURN
  687. > PROCEDURE set_rgb(r%,g%,b%,VAR colr%)
  688.   colr%=SHL(r%,8)+SHL(g%,4)+b%
  689. RETURN
  690. > PROCEDURE save_color_registers(VAR colr$)
  691.   LOCAL i%
  692.   colr$=""
  693.   FOR i%=0 TO 15
  694.     colr$=colr$+MKI$(XBIOS(7,i%,-1))
  695.   NEXT i%
  696. RETURN
  697. > PROCEDURE restore_color_registers(colr$)
  698.   ~XBIOS(6,L:V:colr$)
  699. RETURN
  700. '
  701. > PROCEDURE do_mono_color_dialog
  702.   LOCAL button%
  703.   '
  704.   ' Initialize the radio buttons
  705.   IF editor_colors%(0)<>0
  706.     OB_STATE(dcolrmon_tree%,dcmnorm%)=BSET(OB_STATE(dcolrmon_tree%,dcmnorm%),0)
  707.     OB_STATE(dcolrmon_tree%,dcminvrs%)=BCLR(OB_STATE(dcolrmon_tree%,dcminvrs%),0)
  708.   ELSE
  709.     OB_STATE(dcolrmon_tree%,dcmnorm%)=BCLR(OB_STATE(dcolrmon_tree%,dcmnorm%),0)
  710.     OB_STATE(dcolrmon_tree%,dcminvrs%)=BSET(OB_STATE(dcolrmon_tree%,dcminvrs%),0)
  711.   ENDIF
  712.   ' animate the dialog
  713.   do_dialog(dcolrmon_tree%,0,button%)
  714.   IF button%=dcmok%
  715.     ' Save users new color choice
  716.     IF BTST(OB_STATE(dcolrmon_tree%,dcmnorm%),0)
  717.       editor_colors%(0)=&H777
  718.       editor_colors%(3)=&H0
  719.     ELSE
  720.       editor_colors%(0)=&H0
  721.       editor_colors%(3)=&H777
  722.     ENDIF
  723.   ENDIF
  724. RETURN
  725. > PROCEDURE do_deflist_dialog
  726.   LOCAL button%,i%
  727.   ' Deselect all radio buttons
  728.   FOR i%=0 TO 3
  729.     OB_STATE(ddeflist_tree%,dde0%+i%)=BCLR(OB_STATE(ddeflist_tree%,dde0%+i%),0)
  730.   NEXT i%
  731.   ' Select the radio button which corresponds to current DEFLIST value
  732.   OB_STATE(ddeflist_tree%,dde0%+default_deflist%)=BSET(OB_STATE(ddeflist_tree%,dde0%+default_deflist%),0)
  733.   ' Animate the dialog
  734.   do_dialog(ddeflist_tree%,0,button%)
  735.   IF button%=ddeok%
  736.     ' Find the selected radio button and update current DEFLIST value
  737.     FOR i%=0 TO 3
  738.       EXIT IF BTST(OB_STATE(ddeflist_tree%,dde0%+i%),0)
  739.     NEXT i%
  740.     default_deflist%=i%
  741.   ENDIF
  742. RETURN
  743. > PROCEDURE do_llist_dialog
  744.   LOCAL button%
  745.   '
  746.   ' Initialize the text fields
  747.   CHAR{{OB_SPEC(dllist_tree%,dllpl%)}}=STR$(default_pl%)
  748.   CHAR{{OB_SPEC(dllist_tree%,dllll%)}}=STR$(default_ll%)
  749.   CHAR{{OB_SPEC(dllist_tree%,dllhe%)}}=default_he$
  750.   CHAR{{OB_SPEC(dllist_tree%,dllfo%)}}=default_fo$
  751.   CHAR{{OB_SPEC(dllist_tree%,dllin%)}}=default_in$
  752.   CHAR{{OB_SPEC(dllist_tree%,dllff%)}}=default_ff$
  753.   '
  754.   ' Animate the dialog box
  755.   do_dialog(dllist_tree%,dllpl%,button%)
  756.   '
  757.   IF button%=dllok%
  758.     ' save the new information to our global variables
  759.     default_pl%=VAL(CHAR{{OB_SPEC(dllist_tree%,dllpl%)}})
  760.     default_ll%=VAL(CHAR{{OB_SPEC(dllist_tree%,dllll%)}})
  761.     default_he$=CHAR{{OB_SPEC(dllist_tree%,dllhe%)}}
  762.     default_fo$=CHAR{{OB_SPEC(dllist_tree%,dllfo%)}}
  763.     default_in$=CHAR{{OB_SPEC(dllist_tree%,dllin%)}}
  764.     default_ff$=CHAR{{OB_SPEC(dllist_tree%,dllff%)}}
  765.   ENDIF
  766. RETURN
  767. > PROCEDURE do_program_dialog
  768.   LOCAL t$,b%,button%
  769.   '
  770.   ' Install current program name into dialog text
  771.   CHAR{{OB_SPEC(dprogram_tree%,dprtext%)}}=auto_program$
  772.   '
  773.   DO
  774.     ' Animate the dialog
  775.     do_dialog(dprogram_tree%,dprtext%,button%)
  776.     '
  777.     EXIT IF button%=dprok% OR button%=dprcancl%
  778.     '
  779.     ' User did not press OK or CANCEL so we know he pressed File Selector button
  780.     t$=CHAR{{OB_SPEC(dprogram_tree%,dprtext%)}}
  781.     @select_file("GFA","Select auto program for GFABASRO.PRG",t$,b%)
  782.     IF b%
  783.       IF RIGHT$(t$,1)="\"
  784.         CHAR{{OB_SPEC(dprogram_tree%,dprtext%)}}=""
  785.       ELSE
  786.         CHAR{{OB_SPEC(dprogram_tree%,dprtext%)}}=LEFT$(t$,63)
  787.       ENDIF
  788.     ENDIF
  789.   LOOP
  790.   IF button%=dprok%
  791.     ' Save the new default program name in our global variable
  792.     auto_program$=CHAR{{OB_SPEC(dprogram_tree%,dprtext%)}}
  793.   ENDIF
  794. RETURN
  795. > PROCEDURE do_dialog(tree%,start%,VAR button%)
  796.   ' This procedure is a general dialog handler
  797.   ' tree% is the dialog tree to process
  798.   ' start% is index of first editable text field (0 if no editable field)
  799.   ' button% - Exit button index will be returned through this variable
  800.   '
  801.   LOCAL x%,y%,w%,h%
  802.   '
  803.   ' Center and draw the dialog
  804.   ~FORM_CENTER(tree%,x%,y%,w%,h%)
  805.   ~FORM_DIAL(0,0,0,0,0,x%,y%,w%,h%)
  806.   ~OBJC_DRAW(tree%,0,10,x%,y%,w%,h%)
  807.   '
  808.   ' Animate the dialog
  809.   button%=FORM_DO(tree%,start%)
  810.   '
  811.   ' The next line masks off high bit of exit button which is set if button
  812.   ' was 'touchexit' and user double-clicked.
  813.   button%=AND(button%,&H7FFF)
  814.   '
  815.   ' Deselect the exit button so it will not be inverse next time it is drawn
  816.   OB_STATE(tree%,button%)=BCLR(OB_STATE(tree%,button%),0)
  817.   '
  818.   ' Tell GEM to redraw the screen area that was occupied by our dialog
  819.   ~FORM_DIAL(3,0,0,0,0,x%,y%,w%,h%)
  820. RETURN
  821. > PROCEDURE error_exit
  822.   ' When an error occurs we want to make sure we erase the menu and free
  823.   ' the resource. We then display an alert box to explain the error.
  824.   ~MENU_BAR(menu_tree%,0)
  825.   ~RSRC_FREE()
  826.   CLS
  827.   ~FORM_ALERT(1,ERR$(ERR))
  828.   END
  829. RETURN
  830. '
  831. '
  832. '
  833. '
  834. ' The following are some general file and path name utilities used by
  835. ' this program.
  836. '
  837. > PROCEDURE select_file(extension$,message$,VAR filename$,button%)
  838.   LOCAL i%,temppath$,tempname$
  839.   tempname$=""
  840.   temppath$=""
  841.   IF LEN(filename$)>0
  842.     @sf_parse_filename(filename$,extension$,temppath$,tempname$)
  843.   ENDIF
  844.   IF LEN(temppath$)<1
  845.     temppath$=@current_directory$+"*."+extension$
  846.   ENDIF
  847.   IF LEN(message$)>0
  848.     @sf_domesg(message$,1,gp$)
  849.   ENDIF
  850.   FILESELECT temppath$,tempname$,filename$
  851.   IF LEN(message$)>0
  852.     @sf_domesg(message$,0,gp$)
  853.   ENDIF
  854.   IF filename$=""
  855.     filename$=@directory_only$(temppath$)
  856.     button%=0
  857.   ELSE
  858.     button%=1
  859.   ENDIF
  860. RETURN
  861. > PROCEDURE sf_parse_filename(VAR fullname$,extension$,pathname$,filename$)
  862.   ' This procedure is used by the selectfile() procedure
  863.   '
  864.   LOCAL i%
  865.   i%=LEN(fullname$)
  866.   WHILE i%>=1 AND MID$(fullname$,i%,1)<>"\" AND MID$(fullname$,i%,1)<>":"
  867.     DEC i%
  868.   WEND
  869.   IF i%<1
  870.     filename$=fullname$
  871.     pathname$=""
  872.   ELSE
  873.     IF i%>=LEN(fullname$)
  874.       filename$=""
  875.     ELSE
  876.       filename$=MID$(fullname$,i%+1)
  877.     ENDIF
  878.     pathname$=MID$(fullname$,1,i%)+"*."+extension$
  879.   ENDIF
  880. RETURN
  881. > PROCEDURE sf_domesg(mesg$,flag%,VAR gp$)
  882.   ' This procedure is used by the select_file procedure
  883.   LOCAL bx%,by%,bw%,bh%,wx%,wy%,ww%,wh%
  884.   LOCAL mesgted$,mesgbox$,mesgtree%
  885.   mesg$=LEFT$(mesg$,38)+CHR$(0)
  886.   mesgted$=MKL$(V:mesg$)+MKL$(0)+MKL$(0)+MKI$(3)+MKI$(0)+MKI$(2)+MKI$(&X1000110000000)+MKI$(0)+MKI$(2)+MKI$(LEN(mesg$))+MKI$(0)
  887.   mesgbox$=MKI$(-1)+MKI$(-1)+MKI$(-1)+MKI$(22)+MKI$(32)+MKI$(16)+MKL$(V:mesgted$)+MKI$(0)+MKI$(0)+MKI$(40)+MKI$(2)
  888.   mesgtree%=V:mesgbox$
  889.   ~RSRC_OBFIX(mesgtree%,0)
  890.   ~WIND_GET(0,4,wx%,wy%,ww%,wh%)
  891.   ~FORM_CENTER(mesgtree%,bx%,by%,bw%,bh%)
  892.   OB_Y(mesgtree%,0)=ADD(wy%,3)
  893.   by%=wy%
  894.   IF flag%=1
  895.     GET bx%,by%,ADD(bx%,bw%),ADD(by%,bh%),gp$
  896.     ~OBJC_DRAW(mesgtree%,0,5,bx%,by%,bw%,bh%)
  897.   ELSE
  898.     PUT bx%,by%,gp$,3
  899.   ENDIF
  900. RETURN
  901. '
  902. '
  903. FUNCTION new_extension$(oldname$,extension$)
  904.   ' replaces extension part of oldname$ with extension$ and returns result
  905.   ' EXAMPLE:
  906.   '    f$=@new_extension$("D:\MYPROGS\PROGRAM.LST", "BAS")
  907.   ' after this call the variable f$ will contain "D:\MYPROGS\PROGRAM.BAS"
  908.   '
  909.   LOCAL i%
  910.   i%=LEN(oldname$)
  911.   WHILE i%>1 AND MID$(oldname$,i%,1)<>"." AND MID$(oldname$,i%,1)<>"\"
  912.     DEC i%
  913.   WEND
  914.   IF MID$(oldname$,i%,1)<>"."
  915.     RETURN oldname$+"."+extension$
  916.   ELSE
  917.     RETURN MID$(oldname$,1,i%)+extension$
  918.   ENDIF
  919. ENDFUNC
  920. '
  921. '
  922. FUNCTION filename_only$(fullpath$)
  923.   ' takes complete path name in fullpath$ and returns only the file name
  924.   ' EXAMPLE:
  925.   '    f$=@filename_only$("B:\BASIC\PROGRAMS\MYPROG.BAS")
  926.   ' after this call f$ will contain "MYPROG.BAS"
  927.   '
  928.   LOCAL i%
  929.   i%=LEN(fullpath$)
  930.   WHILE i%>=1 AND MID$(fullpath$,i%,1)<>"\"
  931.     DEC i%
  932.   WEND
  933.   IF i%=LEN(fullpath$)
  934.     RETURN ""
  935.   ELSE
  936.     RETURN MID$(fullpath$,i%+1)
  937.   ENDIF
  938. ENDFUNC
  939. '
  940. '
  941. FUNCTION directory_only$(fullpath$)
  942.   ' takes complete path name in fullpath$ and returns path without file name
  943.   ' EXAMPLE:
  944.   '    f$=@directory_only$("B:\BASIC\PROGRAMS\MYPROG.BAS")
  945.   ' after this call f$ will contain "B:\BASIC\PROGRAMS\"
  946.   '
  947.   LOCAL i%
  948.   i%=LEN(fullpath$)
  949.   WHILE i%>=1 AND MID$(fullpath$,i%,1)<>"\"
  950.     DEC i%
  951.   WEND
  952.   IF (i%<1)
  953.     RETURN ""
  954.   ELSE
  955.     RETURN MID$(fullpath$,1,i%)
  956.   ENDIF
  957. ENDFUNC
  958. '
  959. '
  960. FUNCTION current_directory$
  961.   ' Returns current (default) directory
  962.   ' EXAMPLE:
  963.   '    d$=@current_directory$
  964.   ' After this call the variable p$ will contain the default directory name
  965.   '
  966.   RETURN CHR$(GEMDOS(25)+65)+":"+DIR$(GEMDOS(25)+1)+"\"
  967. ENDFUNC
  968. '
  969. '
  970.